# adult data
# model_selection = c("adult_vision", "adult_vision_sound", "baseline", "matching")
# computational models
model_selection = c("vision", "both", "baseline", "matching")
df.fits = df.choices %>%
mutate(answer = factor(answer, levels = 1:3)) %>%
left_join(df.predictions %>%
select(world, answer, all_of(model_selection)),
by = c("world", "answer")) %>%
mutate(across(all_of(model_selection), ~ ifelse(. == 0, 0.01, .))) %>%
group_by(age, participant) %>%
summarize(across(all_of(model_selection), ~ exp(sum(log(.))))) %>%
ungroup() %>%
rowwise() %>%
mutate(sum = sum(c_across(all_of(model_selection))),
across(all_of(model_selection), ~ . / sum)) %>%
select(-sum)# model_selection = c("adult_vision", "adult_vision_sound", "baseline", "matching")
# computational models
model_selection = c("vision", "both", "baseline", "matching")
df.fits.adults = df.adults %>%
mutate(answer = as.factor(answer)) %>%
filter(world %in% unique(df.choices$world)) %>%
left_join(df.predictions %>%
select(world, answer, all_of(model_selection)),
by = c("world", "answer")) %>%
mutate(across(all_of(model_selection), ~ ifelse(. == 0, 0.01, .))) %>%
group_by(experiment, participant) %>%
summarize(across(all_of(model_selection), ~ exp(sum(log(.))))) %>%
ungroup() %>%
rowwise() %>%
mutate(sum = sum(c_across(all_of(model_selection))),
across(all_of(model_selection), ~ . / sum)) %>%
select(-sum)df.predictions %>%
select(matching, vision, both) %>%
# correlate(method = "spearman") %>%
correlate() %>%
shave() %>%
fashion() term matching vision both
1 matching
2 vision .46
3 both .10 .57
df.choices %>%
mutate(age = as.character(age)) %>%
group_by(age) %>%
summarize(pct_correct = sum(correct)/n()) %>%
bind_rows(df.adults %>%
filter(experiment == "vision_sound") %>%
mutate(correct = answer == ground_truth) %>%
summarize(pct_correct = sum(correct)/n()) %>%
mutate(age = "adult",
.before = pct_correct)) %>%
print_table()| age | pct_correct |
|---|---|
| 3 | 0.32 |
| 4 | 0.30 |
| 5 | 0.36 |
| 6 | 0.37 |
| 7 | 0.43 |
| 8 | 0.58 |
| adult | 0.67 |
df.stat = df.choices %>%
select(participant, age, trial, answer) %>%
mutate(answer = as.factor(answer))
fit.age_answer = brm(formula = answer ~ 1 + age + (1 | participant),
data = df.stat,
family = categorical(),
seed = 1,
file = "cache/fit.age_answer")df.stat = df.choices %>%
select(participant, age, trial, correct)
fit.age_correct = brm(formula = correct ~ 1 + age + (1 | participant),
data = df.stat,
family = "bernoulli",
seed = 1,
file = "cache/fit.age_correct")
fit.age_correct Family: bernoulli
Links: mu = logit
Formula: correct ~ 1 + age + (1 | participant)
Data: df.stat (Number of observations: 576)
Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
total post-warmup draws = 4000
Group-Level Effects:
~participant (Number of levels: 64)
Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
sd(Intercept) 0.35 0.17 0.04 0.67 1.00 927 921
Population-Level Effects:
Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
Intercept -1.65 0.34 -2.36 -1.00 1.00 4212 2815
age 0.22 0.06 0.11 0.33 1.00 4324 2657
Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
and Tail_ESS are effective sample size measures, and Rhat is the potential
scale reduction factor on split chains (at convergence, Rhat = 1).
# 7 year olds
df.stat = df.choices %>%
select(participant, age, trial, correct) %>%
filter(age == 7)
fit.seven_correct = brm(formula = correct ~ 1 + (1 | participant),
data = df.stat,
family = "bernoulli",
seed = 1,
file = "cache/fit.seven_correct")
# 8 year olds
df.stat = df.choices %>%
select(participant, age, trial, correct) %>%
filter(age == 8)
fit.eight_correct = brm(formula = correct ~ 1 + (1 | participant),
data = df.stat,
family = "bernoulli",
seed = 1,
file = "cache/fit.eight_correct")
# results (in probability scale)
fit.seven_correct %>%
tidy() %>%
filter(effect == "fixed") %>%
select(estimate, contains("conf")) %>%
mutate(across(.cols = everything(),
.fns = ~ inv.logit(.)))# A tibble: 1 × 3
estimate conf.low conf.high
<dbl> <dbl> <dbl>
1 0.429 0.292 0.562
fit.eight_correct %>%
tidy() %>%
filter(effect == "fixed") %>%
select(estimate, contains("conf")) %>%
mutate(across(.cols = everything(),
.fns = ~ inv.logit(.)))# A tibble: 1 × 3
estimate conf.low conf.high
<dbl> <dbl> <dbl>
1 0.593 0.441 0.733
df.fits %>%
ungroup() %>%
filter(age < 6) %>%
summarize(matching = mean(matching))# A tibble: 1 × 1
matching
<dbl>
1 0.577
df.fits %>%
ungroup() %>%
filter(age < 6) %>%
summarize(simulation = mean(vision) + mean(both))# A tibble: 1 × 1
simulation
<dbl>
1 0.252
df.fits %>%
ungroup() %>%
filter(age == 3) %>%
summarize(guessing = mean(baseline))# A tibble: 1 × 1
guessing
<dbl>
1 0.198
df.fits %>%
ungroup() %>%
filter(age >= 6) %>%
summarize(simulation = mean(vision) + mean(both))# A tibble: 1 × 1
simulation
<dbl>
1 0.546
df.fits %>%
ungroup() %>%
filter(age == 8) %>%
summarize(simulation = mean(both))# A tibble: 1 × 1
simulation
<dbl>
1 0.473
models = c("baseline", "matching", "vision", "both")
models = c("baseline", "matching", "adult_vision", "adult_vision_sound")
df.plot = df.predictions %>%
select(world, answer, all_of(models)) %>%
pivot_longer(cols = -c(world, answer),
names_to = "model",
values_to = "prediction") %>%
filter(model %in% models) %>%
mutate(model = factor(model,
levels = models,
# labels = c("guessing", "matching", "vision", "vision & sound")))
labels = c("guessing", "matching",
"simulation (vision)","simulation (vision & sound)")))
func_load_image = function(world){
readPNG(str_c("../../figures/ground_truth/trial_", world, ".png"))
}
# linking images and worlds
df.images = df.plot %>%
distinct(world) %>%
arrange(world) %>%
mutate(grob = map(.x = world,
.f = ~ func_load_image(world = .x)))
df.text = df.plot %>%
distinct(world) %>%
arrange(world) %>%
mutate(index = 1:n(),
x = 0.8,
y = Inf)
# plotting
p = ggplot(data = df.plot,
mapping = aes(x = answer,
y = prediction)) +
geom_col(mapping = aes(fill = model,
group = model),
position = position_dodge(width = 0.9),
color = "black") +
geom_hline(yintercept = 1/3,
linetype = 2) +
geom_custom(data = df.images,
mapping = aes(data = grob,
x = -Inf,
y = Inf),
grob_fun = function(x) rasterGrob(x,
interpolate = T,
vjust = -0.05,
hjust = 0)) +
geom_text(data = df.text,
mapping = aes(x = x,
y = y,
label = index),
size = 12,
color = "white",
vjust = -4) +
facet_wrap(~ world,
nrow = 1) +
labs(y = "proportion %") +
scale_size_manual(values = c(0.5, 1.5)) +
scale_y_continuous(breaks = seq(0, 1, 0.25),
labels = str_c(seq(0, 100, 25), "%"),
limits = c(0, 1),
expand = expansion(add = c(0, 0))) +
coord_cartesian(clip = "off") +
scale_fill_brewer(palette = "Set1") +
theme(panel.grid.major.y = element_line(),
axis.text.y = element_text(size = 25),
axis.text.x = element_text(size = 25),
axis.title = element_blank(),
legend.position = "bottom",
strip.background = element_blank(),
strip.text = element_blank(),
panel.background = element_rect(fill = NA, color = "black"),
panel.spacing.x = unit(0.5, "cm"),
plot.margin = margin(t = 5, l = 1, r = 0.2, b = 0, unit = "cm"))
p
ggsave(filename = "../../figures/plots/model_predictions_adults.pdf",
# ggsave(filename = "../../figures/plots/model_predictions_models.pdf",
width = 22,
height = 5)df.plot = df.predictions %>%
select(world, answer, baseline, matching, vision, both) %>%
pivot_longer(cols = c(baseline, matching, vision, both),
names_to = "model",
values_to = "prediction") %>%
filter(model %in% c("baseline", "matching", "vision", "both")) %>%
mutate(model = factor(model,
levels = c("baseline", "matching", "vision", "both"),
labels = c("baseline", "matching", "vision", "vision & sound")))
func_load_image = function(world){
readPNG(str_c("../../figures/ground_truth/trial_", world, ".png"))
}
# linking images and worlds
df.images = df.plot %>%
distinct(world) %>%
arrange(world) %>%
mutate(grob = map(.x = world,
.f = ~ func_load_image(world = .x)))
# plotting
p = ggplot(data = df.plot,
mapping = aes(x = answer,
y = prediction)) +
geom_col(mapping = aes(fill = model,
group = model),
position = position_dodge(width = 0.9),
color = "black") +
geom_hline(yintercept = 1/3,
linetype = 2) +
geom_custom(data = df.images,
mapping = aes(data = grob,
x = -Inf,
y = Inf),
grob_fun = function(x) rasterGrob(x,
interpolate = T,
vjust = -0.05,
hjust = 0)) +
facet_wrap(~ world,
nrow = 3) +
labs(y = "proportion %") +
scale_size_manual(values = c(0.5, 1.5)) +
scale_y_continuous(breaks = seq(0, 1, 0.25),
labels = str_c(seq(0, 100, 25), "%"),
limits = c(0, 1),
expand = expansion(add = c(0, 0))) +
coord_cartesian(clip = "off") +
scale_fill_brewer(palette = "Set1") +
theme(panel.grid.major.y = element_line(),
axis.text.y = element_text(size = 25),
axis.text.x = element_text(size = 25),
axis.title = element_blank(),
legend.position = "bottom",
strip.background = element_blank(),
strip.text = element_blank(),
panel.background = element_rect(fill = NA, color = "black"),
panel.spacing.x = unit(0.5, "cm"),
panel.spacing.y = unit(6.5, "cm"),
plot.margin = margin(t = 6.5, l = 1, r = 0.2, b = 0, unit = "cm"))
p
ggsave(filename = "../../figures/plots/model_predictions_3by3.pdf",
width = 10,
height = 18)# p1 = func_plot_with_images(data = df.choices %>%
# filter(age == 3),
# model = df.predictions)
p1 = func_plot_with_images(data = df.choices %>%
filter(age == 3),
model = df.predictions)
p2 = func_plot_with_images(data = df.choices %>%
filter(age == 4),
model = df.predictions)
p3 = func_plot_with_images(data = df.choices %>%
filter(age == 5),
model = df.predictions)
p4 = func_plot_with_images(data = df.choices %>%
filter(age == 6),
model = df.predictions)
p5 = func_plot_with_images(data = df.choices %>%
filter(age == 7),
model = df.predictions)
p6 = func_plot_with_images(data = df.choices %>%
filter(age == 8),
model = df.predictions)
p1 + p2 + p3 + p4 + p5 + p6 +
plot_layout(ncol = 1,
tag_level = "new") +
plot_annotation(tag_levels = "A")